COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	-*-LISP-*-
C00004 00003
C00013 ENDMK
C⊗;
;;;-*-LISP-*-
;;;; Scheme objects formatting

(herald sprint "")
(include "umacro.lsp")
(include "smacro.lsp")

;;; Code if inside lambda, define or procedure.
;;; Inhibits use of fboundp in gdispatch by shadowing old definition.

(defmacro fboundp (object)
  (cond ((eq object 'head) '*code*)
	(T `(subrcall nil (get 'fboundp 'subr) ,object))))

;;; Include gprint

(declare (*lexpr gf))
;(include "gprint.lsp")

;;; Scheme initializations:

(setq prinlevel nil)
(setq prinlength nil)
(setq prinendline nil)

;;; Terse and no terse printing:

(defvar *terse?* t "Controls mode: Nil for terse printing, T opposite")
(defvar *code* nil "Controls whether a list being formatted is code or data")


;;;; Scheme printers and explode.  Printers will abort on ↑P
;;; Load smacro so global variables and parts of delayed objects can be
;;;accessed

(eval-when (compile) (load "smacro.lsp"))

;;; Set up ↑P to throw to printers

(sstatus ttyint #↑P
	 #'(lambda (x y)
		(let ((errset nil))
		  (errset (*throw 'abort-print *noprint*)
			  nil))))

(defmacro defschprinter (name kind extra-lets resultp)
  `(defun ,name (obj &optional (file *OUTSTREAM*) (format nil))
     (let (,@extra-lets
	   (prinlevel (relative-lexical-access nil '*print-depth*))
	   (prinlength (relative-lexical-access nil '*print-breadth*))
	   (gcheckrecursion (relative-lexical-access nil
						     '*check-circularity*)))
       ,(if resultp `(,kind obj file format)
	    `(*catch 'abort-print
	       (,kind obj file format)
	       *noprint*)))))


(defschprinter schprint gprint nil nil)

(defschprinter schprinc gprintc nil nil)

(defschprinter schprin1 gprint1 nil nil)

(defschprinter schpp gprint ((*terse?* nil)) nil)

(defschprinter schexplode gexplodec nil t)

;;; Displaying messages:

(defmacro stringp (obj)
  `(and (symbolp ,obj) (< (flatc ,obj) (flatsize ,obj))))

(defun display things
  (schprint (cons '*display-gformat*
		  (separate (reverse (listify things)) nil nil))))

(defun separate (rest this done)
  (cond ((null rest)
	 (cond ((null this)
		done)
	       (t (cons this done))))
	((stringp (car rest))
	 (separate (cdr rest)
		   nil
		   (cons (cons (car rest) this) done)))
	(t (separate (cdr rest) (cons (car rest) this) done))))

(defun (*display-gformat* :gformat) (item)
  (GF "{2%disp-first }" (cdr item)))

(defun disp-first (object)
  (cond ((null object) nil)
	(t (GF "{4C[<←N*>]}←N%disp-more"    ;So all vals will have same ind.
	       (caar object) (cdar object) (cdr object)))))

(defun disp-more (object)
  (cond ((null object) nil)
	(t (GF "{2C[<←N*>]}←N%disp-more"
	       (caar object) (cdar object) (cdr object)))))

(defmacro scheme-GF (pattern arg)
  `(if (null *code*)
       (:Gfn-format ,arg)
       (GF ,pattern ,arg)))

;;; Scheme special forms:

(defun-default-Gformat set! (x)
  (scheme-GF "(*←*<←B*←A*>)" x))

;;; To inhibit loading messages (these functions are defined in gprint too)

(remprop 'quote ':gformat)
(setplist '|QUOTE-:Gformat| nil)
(remprop 'function ':gformat)
(setplist '|FUNCTION-:Gformat| nil)
(remprop 'lambda ':gformat)
(setplist '|LAMBDA-:Gformat| nil)
(remprop 'let ':gformat)
(setplist '|LET-:Gformat| nil)


(defun-default-Gformat quote (x)
  (if (not (and (pairp (cdr x))
		(null (cddr x))))
      (:Gfn-format x)
      (GF "{0''''*}" (cadr x))))
  
(defun-default-Gformat lambda (list)
  (Gcheck-indentation list
    #'(lambda (x)
	(scheme-GF "(2{*←N%gformat-arglist }<←N*>)" x))))

(defun-default-Gformat let (list)
  (Gcheck-indentation list
    #'(lambda (x)
	(scheme-GF "(2*←%gformat-letexp <←N*>)" x))))

(defun-default-Gformat define (obj)
  (Gcheck-indentation obj	
    #'(lambda (x)
	(scheme-GF (if (atom (cadr x))
		       "(*←*<←B*←A*>)"
		       "(4*←$:Gblock <←N*>)")
		   x))))
  
(defun-default-Gformat sequence (obj)
  (Gcheck-indentation obj
    #'(lambda (x)
	(scheme-GF "(4*<←N*>)" x))))

(defun-default-Gformat catch (obj)
  (Gcheck-indentation obj
    #'(lambda (x)
	(scheme-GF "(4{*←N*}<←N*>)" x))))

(defun-default-Gformat dynamic-wind (obj)
  (Gcheck-indentation obj
    #'(lambda (x)
	(scheme-GF "(4*<←N*>)" x))))

(defun-default-Gformat fluid-let (list)
  (Gcheck-indentation list
    #'(lambda (x)
	(scheme-GF "(2*←%gformat-letexp <←N*>)" x))))

;;; Scheme data type formatting:

(defun scheme-object-formatter (object)
  (funcall (get (primitive-type object) 'gprint) object)
  T)

(setq Ghunk-formatters (list #'scheme-object-formatter))

(defun (primitive-procedure gprint) (proc)
  (GF "{4'[PRIMITIVE'←1NP']'}" (sch-procedure-name proc)))

(defun (compound-procedure gprint) (proc)
  (let ((nam (sch-procedure-name proc))
	(*code* t))
    (cond ((null nam)
	   (cond (*terse?*
		  (GF "{4'[LAMBDA-PROCEDURE'←1NP']'}" (maknum proc)))
		 (T
		  (GF "{4{7'[LAMBDA-PROCEDURE'←1N%gformat-arglist }[<←N*>]']'}"
		      (sch-procedure-formals proc)
		      (sch-procedure-body proc)))))
	  (T (cond (*terse?*
		    (GF "{4'[PROCEDURE'←1NP']'}" nam))
		   (T (GF "{4{7'[PROCEDURE'←1N*} [<←N*>]']'}"
			  (cons nam (sch-procedure-formals proc))
			  (sch-procedure-body proc))))))))

(defmacro null-format (object def-format)
  `(cond ((null ,object)
	  (GF "'()'"))
	 (t (GF ,def-format ,object))))

(defun gformat-arglist (object)
  (null-format object "$:Gblock "))

(defun gformat-letexp (object)
  (null-format object "(1(1$:Gblock ←B*) <←N$/"A(1$:Gblock ←B*)/" >)"))

(defun (environment gprint) (env)
  (GF "{4'[ENVIRONMENT'←1NP']'}" (maknum env)))

(defun (control-point gprint) (cp)
  (GF "{4'[CONTROL-POINT'←1NP']'}" (maknum cp)))

(defun (delayed-object gprint) (obj)
  (cond ((already-forced? obj)
	 (GF "*" (forced-value obj)))
	(t (let ((*code* t))
	     (GF "{4'[DELAYED-OBJECT'←1N*']'}"
		 (unsyntax (delayed-expression obj)))))))

(defun (array gprint) (arr)
  (cond (*terse?*
	 (GF "{4'[ARRAY'←1NP']'}" (maknum arr)))
	(T (GF "{4'[ARRAY'←1NP←1N$:Gblock ']'}"
	       (maknum arr) (scharraydims arr)))))

(defun (unidentified-object gprint) (obj)
  (GF "{4'[RANDOM-OBJECT'←1NP']'}" (maknum obj)))